home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / oobr / eif-ise-er.el < prev    next >
Encoding:
Text File  |  1995-04-28  |  9.2 KB  |  243 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         eif-ise-er.el
  4. ;; SUMMARY:      Parses ISE's Eiffel error messages; compiles Eiffel classes.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     oop, tools
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Motorola Inc.
  10. ;;
  11. ;; ORIG-DATE:     7-Dec-89 at 00:17:18
  12. ;; LAST-MOD:     17-Apr-95 at 12:39:18 by Bob Weiner
  13. ;;
  14. ;; Copyright (C) 1989-1995  Free Software Foundation, Inc.
  15. ;; See the file BR-COPY for license information.
  16. ;;
  17. ;; This file is part of the OO-Browser.
  18. ;;
  19. ;; DESCRIPTION:  
  20. ;;
  21. ;;   'eif-ec' compiles an Eiffel class.
  22. ;;   'eif-es' compiles an Eiffel system.
  23. ;;
  24. ;;   Load this library and then invoke error parsing via {C-x `}.
  25. ;;   See the GNU Emacs Manual for an explanation of error parsing.
  26. ;;
  27. ;;   'eif-ise-next-error' bound to {C-x `} parses ISE Eiffel compiler
  28. ;;   error messages.  As in: 
  29. ;;
  30. ;;   "my_class", 16: syntax error : Keyword 'expanded' may not be used as identifier
  31. ;;
  32. ;;   Only handles compilation lines of the following form:
  33. ;;
  34. ;;      <compiler> [<option> ... <option>] <pathname>
  35. ;;
  36. ;;   Requires the 'br-class-path', 'br-build-sys-paths-htable', and
  37. ;;   'br-build-paths-htable' functions from the OO-Browser 'br-lib' package.
  38. ;;   This is used to determine the full pathname for the source code of each
  39. ;;   class since ISE does not include any pathname information in its error
  40. ;;   messages.
  41. ;;
  42. ;;
  43. ;;   To reset the {C-x `} key to parse non-Eiffel error messages, use:
  44. ;;
  45. ;;           {M-x load-lib RTN compile RTN}
  46. ;;
  47. ;; DESCRIP-END.
  48.  
  49. (require 'br-lib)
  50. (require 'br-eif)
  51. (require 'compile)
  52.  
  53. (global-set-key "\C-x`" 'eif-ise-next-error)
  54. (and (boundp 'eiffel-mode-map) (define-key eiffel-mode-map "\C-c!" 'eif-ec))
  55.  
  56. (setq compilation-error-regexp "\"\\([^ \t]+\\)\", \\([0-9]+\\):.*")
  57.  
  58. (defconst eif-compile-dir nil
  59.   "Default directory in which to invoke an Eiffel compile command.")
  60.  
  61. (defconst eif-compile-cmd "ec"
  62.   "Default command name with which to invoke the Eiffel compiler.")
  63.  
  64. (defun eif-ise-next-error (&optional argp)
  65.   "Visit next compilation error message and corresponding source code.
  66. This operates on the output from the \\[compile] command.
  67. If all preparsed error messages have been processed,
  68. the error message buffer is checked for new ones.
  69. A non-nil argument (prefix arg, if interactive)
  70. means reparse the error message buffer and start at the first error."
  71.   (interactive "P")
  72.   (if (or (eq compilation-error-list t)
  73.       argp)
  74.       (progn (compilation-forget-errors)
  75.          (setq compilation-parsing-end 1)))
  76.   (if compilation-error-list
  77.       nil
  78.     (save-excursion
  79.       (switch-to-buffer "*compilation*")
  80.       (set-buffer-modified-p nil)
  81.       (eif-ise-compilation-parse-errors)))
  82.   (let ((next-error (car compilation-error-list)))
  83.     (if (null next-error)
  84.     (error (concat compilation-error-message
  85.                (if (and compilation-process
  86.                 (eq (process-status compilation-process)
  87.                     'run))
  88.                " yet" ""))))
  89.     (setq compilation-error-list (cdr compilation-error-list))
  90.     (if (null (car (cdr next-error)))
  91.     nil
  92.       (switch-to-buffer (marker-buffer (car (cdr next-error))))
  93.       (goto-char (car (cdr next-error)))
  94.       (set-marker (car (cdr next-error)) nil))
  95.     (let* ((pop-up-windows t)
  96.        (w (display-buffer (marker-buffer (car next-error)))))
  97.       (set-window-point w (car next-error))
  98.       (set-window-start w (car next-error)))
  99.     (set-marker (car next-error) nil)))
  100.  
  101. (defun eif-ise-compilation-filename ()
  102.   "Return a string which is the last filename from the compilation command.
  103. Ignore quotes around it.  Return nil if no filename was given."
  104.   ;; First arg of compile cmd should be filename
  105.   (if (string-match "^.*[ \t]+\\([^ \t\"]+\\)" compile-command)
  106.       (substring compile-command (match-beginning 1) (match-end 1))))
  107.  
  108. (defun eif-ise-compilation-parse-errors ()
  109.   "Parse the current buffer as error messages.
  110. This makes a list of error descriptors, compilation-error-list.  For each
  111. error line-number in the buffer, the source file is read in, and the text
  112. location is saved in compilation-error-list.  The function next-error,
  113. assigned to \\[next-error], takes the next error off the list and visits its
  114. location."
  115.   (setq compilation-error-list nil)
  116.   (message "Parsing error messages...")
  117.   (let (text-buffer
  118.     last-filename last-linenum)
  119.     ;; Don't reparse messages already seen at last parse.
  120.     (goto-char compilation-parsing-end)
  121.     ;; Don't parse the first two lines as error messages.
  122.     ;; This matters for grep.
  123.     (if (bobp)
  124.     (forward-line 2))
  125.     (let (class-name case-fold-search linenum filename error-marker text-marker)
  126.       (while (re-search-forward compilation-error-regexp nil t)
  127.     ;; Extract line number from error message.
  128.     (setq linenum (string-to-int (buffer-substring
  129.                        (match-beginning 2)
  130.                        (match-end 2))))
  131.     ;; Extract class name from error message and convert to the full
  132.     ;; pathname of the class' source file.
  133.     (setq class-name (downcase (buffer-substring (match-beginning 1) (match-end 1)))
  134.           filename (br-class-path class-name))
  135.     (if (null filename) ; No matching class name in lookup table.
  136.         (progn 
  137.           (message "Rebuilding Eiffel system class locations table...")
  138.           (sit-for 2)
  139.           (call-interactively 'br-build-sys-classes-htable) ; Typically pretty fast
  140.           (message "Rebuilding Eiffel system class locations table...Done")
  141.           (setq filename (br-class-path class-name))
  142.           (if (null filename)
  143.           (error (format "'%s' not in lookup table, use {M-x br-build-paths-htable RTN} to update."
  144.                  class-name)))))
  145.     ;; Locate the erring file and line.
  146.     (if (and (equal filename last-filename)
  147.          (= linenum last-linenum))
  148.         nil
  149.       (beginning-of-line 1)
  150.       (setq error-marker (point-marker))
  151.       ;; text-buffer gets the buffer containing this error's file.
  152.       (if (not (equal filename last-filename))
  153.           (setq text-buffer
  154.             (and (file-exists-p (setq last-filename filename))
  155.              (if (boundp 'br-find-file-noselect-function)
  156.                  (set-buffer
  157.                    (funcall br-find-file-noselect-function
  158.                     filename))
  159.                (find-file-noselect filename)))
  160.             last-linenum 0))
  161.       (if text-buffer
  162.           ;; Go to that buffer and find the erring line.
  163.           (save-excursion
  164.         (set-buffer text-buffer)
  165.         (if (zerop last-linenum)
  166.             (progn
  167.               (goto-char 1)
  168.               (setq last-linenum 1)))
  169.         (forward-line (- linenum last-linenum))
  170.         (setq last-linenum linenum)
  171.         (setq text-marker (point-marker))
  172.         (setq compilation-error-list
  173.               (cons (list error-marker text-marker)
  174.                 compilation-error-list)))))
  175.     (forward-line 1)))
  176.     (setq compilation-parsing-end (point-max)))
  177.   (message "Parsing error messages...done")
  178.   (setq compilation-error-list (nreverse compilation-error-list)))
  179.  
  180.  
  181. ;;; The following version of 'eif-ec' courtesy of:
  182. ;;; Heinz W. Schmidt                                     hws@icsi.berkeley.edu
  183. ;;; International Computer Science Institute             (415) 643-9153   x175
  184. ;;; 1947 Center Street, Ste. 600                    /\/\|;; CLOS saves time and
  185. ;;; Berkeley, CA 94704                              \/\/|-- Eiffel is faster
  186. ;;; 2/11/90
  187. ;;; With a number of Bob Weiner's modifications
  188.  
  189. (defun str2argv (STR)
  190.   (if (string-match "[^ ]" STR)
  191.       (let ((arg1 (read-from-string STR)))
  192.         (cons (prin1-to-string (car arg1))
  193.               (str2argv (substring STR (cdr arg1)))))))
  194.  
  195. (defvar eif-ec-args "" "Default arguments to send to the Eiffel ec class compiler.")
  196.  
  197. (defun eif-ec (ARG &optional CMD DIR CLASS-NAME)
  198.   "Calls Eiffel compiler.  Compile with optional CMD, 'eif-compile-cmd' or \"ec\".
  199. By default, the compiler is called on the file associated with the current
  200. buffer.  With numeric argument 0 prompts for explicit command line arguments.
  201. Other numeric arguments allow you to insert options or further class names."
  202.   (interactive "P")
  203.   (setq CLASS-NAME (or CLASS-NAME
  204.                (let ((fn (file-name-nondirectory buffer-file-name)))
  205.              (substring fn 0 (- (length fn) 2))))
  206.     ec-dir (or DIR eif-compile-dir (file-name-directory buffer-file-name)))
  207.   (let* ((ec-output (get-buffer-create "*compilation*"))
  208.          (ec-process (get-buffer-process ec-output))
  209.      (curr-buffer (current-buffer)))
  210.     (if ec-process
  211.         (if (y-or-n-p "Kill current Eiffel compilation process? ")
  212.             (delete-process ec-process)
  213.           (error "Can't ec concurrently.")))
  214.     (if (and (buffer-modified-p)
  215.              (y-or-n-p (format "Save file %s? " buffer-file-name)))
  216.         (progn (save-buffer) (message "")))
  217.     ;; Maybe prompt for args and dispatch according to numeric ARG.
  218.     (setq eif-ec-args (if ARG (read-string "ec args: " eif-ec-args) ""))
  219.     ;; Switch to shell buffer and run ec.
  220.     (set-buffer ec-output)
  221.     (erase-buffer)
  222.     ;; Move to directory and trim classname so ec works in situations
  223.     ;; like: ec -t class1 <CLASS-NAME>
  224.     (cd ec-dir)
  225.     (insert (or CMD eif-compile-cmd "ec")
  226.         (if ARG (format " %s" eif-ec-args) "")
  227.         (format " %s" (if (not (and ARG (zerop ARG))) CLASS-NAME ""))
  228.             "\n")
  229.     (set-buffer curr-buffer)
  230.     (display-buffer ec-output)
  231.     (eval   
  232.      (append '(start-process "ec" ec-output (or CMD eif-compile-cmd "ec"))
  233.              (str2argv eif-ec-args)
  234.              (if (not (and ARG (zerop ARG))) (list CLASS-NAME)))))) 
  235.  
  236. (defun eif-es (&optional dir)
  237.   "Compile Eiffel system with es."
  238.   (interactive)
  239.   (eif-ec nil "es" dir ""))
  240.  
  241.  
  242. (provide 'eif-ise-er)
  243.